home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / kcl-compiler-patches.lisp < prev    next >
Lisp/Scheme  |  1992-06-04  |  8KB  |  219 lines
  1.  
  2. (in-package 'compiler)
  3.  
  4. #+akcl
  5. (eval-when (compile load eval)
  6. (when (<= system::*akcl-version* 609)
  7.   (pushnew :pre_akcl_610 *features*))
  8. )
  9.  
  10. #+pre_akcl_610
  11. (progn
  12.  
  13. ;[without this, xlib:create-window won't work]
  14. ;added inline-integer here.
  15. (defun get-inline-loc (ii args &aux (fun (car (cdddr ii))) locs)
  16.   ;;; Those functions that use GET-INLINE-LOC must rebind the variable *VS*.
  17.  (setq locs (inline-args args (car ii) fun))
  18.   (when (and (stringp fun) (char= (char (the string fun) 0) #\@))
  19.     (let ((i 1) (saves nil))
  20.          (declare (fixnum i))
  21.       (do ((char (char (the string fun) i)
  22.                  (char (the string fun) i)))
  23.           ((char= char #\;) (incf i))
  24.           (declare (character char))
  25.           (push (the fixnum (- (char-code char) #.(char-code #\0))) saves)
  26.           (incf i))
  27.       (do ((l locs (cdr l))
  28.            (n 0 (1+ n))
  29.            (locs1 nil))
  30.           ((endp l) (setq locs (reverse locs1)))
  31.           (declare (fixnum n) (object l))
  32.           (if (member n saves)
  33.               (let* ((loc1 (car l)) (loc loc1) (coersion nil))
  34.                     (declare (object loc loc1))
  35.                 (when (and (consp loc1)
  36.                            (member (car loc1)
  37.                                    '(FIXNUM-LOC integer-loc CHARACTER-LOC
  38.                                      LONG-FLOAT-LOC SHORT-FLOAT-LOC)))
  39.                       (setq coersion (car loc1))
  40.                       (setq loc (cadr loc1))  ; remove coersion
  41.                       )
  42.                 (cond
  43.                  ((and (consp loc)
  44.                (or
  45.              (member (car loc) 
  46.                                     '(INLINE INLINE-COND))
  47.              (and      (member (car loc)
  48.                      '(
  49.                        INLINE-FIXNUM inline-integer
  50.                        INLINE-CHARACTER INLINE-LONG-FLOAT
  51.                        INLINE-SHORT-FLOAT))
  52.                  (or (flag-p (cadr loc) allocates-new-storage)
  53.                      (flag-p (cadr loc) side-effect-p))
  54.                                 )))
  55.                   (wt-nl "{")
  56.                   (inc-inline-blocks)
  57.                   (let ((cvar (next-cvar)))
  58.                     (push (list 'CVAR cvar) locs1)
  59.                     (case coersion
  60.                      ((nil) (wt "object V" cvar "= ") (wt-loc loc1))
  61.                      (FIXNUM-LOC (wt "int V" cvar "= ") (wt-fixnum-loc loc))
  62.              (integer-loc (wt "GEN V" cvar "= ") (wt-integer-loc loc
  63.                                      'get-inline-locs))
  64.                      (CHARACTER-LOC
  65.                       (wt "unsigned char V" cvar "= ") (wt-character-loc loc))
  66.                      (LONG-FLOAT-LOC
  67.                       (wt "double V" cvar "= ") (wt-long-float-loc loc))
  68.                      (SHORT-FLOAT-LOC
  69.                       (wt "float V" cvar "= ") (wt-short-float-loc loc))
  70.                      (t (baboon))))
  71.                   (wt ";")
  72.                   )
  73.                  (t (push loc1 locs1))))
  74.               (push (car l) locs1)))))
  75.   (list (inline-type (cadr ii))
  76.         (caddr ii)
  77.         fun
  78.         locs)
  79.   )
  80.  
  81. ;added inline-integer
  82. (defun unwind-exit (loc &optional (jump-p nil) fname
  83.                         &aux (*vs* *vs*) (bds-cvar nil) (bds-bind 0) type.wt)
  84.   (declare (fixnum bds-bind))
  85.   (and *record-call-info* (record-call-info loc fname))
  86.   (when (and (eq loc 'fun-val)
  87.              (not (eq *value-to-go* 'return))
  88.              (not (eq *value-to-go* 'top)))
  89.         (wt-nl) (reset-top))
  90.   (cond ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-true))
  91.          (set-jump-true loc (cadr *value-to-go*))
  92.          (when (eq loc t) (return-from unwind-exit)))
  93.         ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-false))
  94.          (set-jump-false loc (cadr *value-to-go*))
  95.          (when (null loc) (return-from unwind-exit))))
  96.   (dolist* (ue *unwind-exit* (baboon))
  97.    (cond
  98.     ((consp ue)
  99.      (cond ((eq ue *exit*)
  100.         (cond ((and (consp *value-to-go*)
  101.             (or (eq (car *value-to-go*) 'jump-true)
  102.                 (eq (car *value-to-go*) 'jump-false)))
  103.            (unwind-bds bds-cvar bds-bind))
  104.           (t
  105.            (if (or bds-cvar   (plusp bds-bind))
  106.                           ;;; Save the value if LOC may possibly refer
  107.                           ;;; to special binding.
  108.                (if (and (consp loc)
  109.                 (or (and (eq (car loc) 'var)
  110.                      (member (var-kind (cadr loc))
  111.                          '(SPECIAL GLOBAL)))
  112.                     (member (car loc)
  113.                         '(SIMPLE-CALL
  114.                           INLINE
  115.                           INLINE-COND INLINE-FIXNUM
  116.                           INLINE-CHARACTER
  117.                           INLINE-INTEGER
  118.                           INLINE-LONG-FLOAT
  119.                           INLINE-SHORT-FLOAT))))
  120.                (cond ((and (consp *value-to-go*)
  121.                        (eq (car *value-to-go*) 'vs))
  122.                   (set-loc loc)
  123.                   (unwind-bds bds-cvar bds-bind))
  124.                  (t (let
  125.                     ((temp (list 'cvar (cs-push))))
  126.                       (let ((*value-to-go* temp))
  127.                     (set-loc loc))
  128.                       (unwind-bds bds-cvar bds-bind)
  129.                       (set-loc temp))))
  130.              (progn (unwind-bds bds-cvar bds-bind)
  131.                 (set-loc loc)))
  132.              (set-loc loc))))
  133.  
  134.         (when jump-p
  135.           (when (consp *inline-blocks*) (wt-nl "restore_avma; "))
  136.           (wt-nl) (wt-go *exit*))
  137.         (return))
  138.        (t (setq jump-p t))))
  139.     ((numberp ue) (setq bds-cvar ue bds-bind 0))
  140.     ((eq ue 'bds-bind) (incf bds-bind))
  141.     ((eq ue 'return)
  142.      (when (eq *exit* 'return)
  143.               ;;; *VALUE-TO-GO* must be either *RETURN* or *TRASH*.
  144.        (set-loc loc)
  145.        (unwind-bds bds-cvar bds-bind)
  146.        (wt-nl "return;")
  147.        (return))
  148.         ;;; Never reached
  149.      )
  150.     ((eq ue 'frame)
  151.      (when (and (consp loc)
  152.         (member (car loc)
  153.             '(SIMPLE-CALL INLINE INLINE-COND INLINE-FIXNUM inline-integer
  154.                       INLINE-CHARACTER INLINE-LONG-FLOAT
  155.                       INLINE-SHORT-FLOAT)))
  156.        (cond ((and (consp *value-to-go*)
  157.            (eq (car *value-to-go*) 'vs))
  158.           (set-loc loc)
  159.           (setq loc *value-to-go*))
  160.          (t (let ((*value-to-go* (if *c-gc* (list 'cvar (cs-push))
  161.                        (list 'vs (vs-push)))))
  162.           (set-loc loc)
  163.           (setq loc *value-to-go*)))))
  164.      (wt-nl "frs_pop();"))
  165.     ((eq ue 'tail-recursion-mark))
  166.     ((eq ue 'jump) (setq jump-p t))
  167.     ((setq type.wt
  168.        (assoc ue
  169.           '((return-fixnum fixnum .  wt-fixnum-loc)
  170.             (return-character character . wt-character-loc)
  171.             (return-short-float short-float . wt-short-float-loc)
  172.             (return-long-float long-float . wt-long-float-loc)
  173.             (return-object t . wt-loc))))
  174.      (let ((cvar (next-cvar)))
  175.        (or (eq *exit* (car type.wt)) (wfs-error))
  176.        (setq type.wt (cdr type.wt))
  177.        (wt-nl "{" (rep-type (car type.wt)) "V" cvar " = ")
  178.        (funcall (cdr type.wt) loc)  (wt ";")
  179.        (unwind-bds bds-cvar bds-bind)
  180.        (wt-nl "VMR" *reservation-cmacro* "(V" cvar")}")
  181.        (return)))
  182.         
  183.     (t (baboon))
  184.        ;;; Never reached
  185.     ))
  186.   )
  187.  
  188. ;added inline-integer
  189. (defun set-loc (loc &aux fd)
  190.   (cond ((eq *value-to-go* 'return) (set-return loc))
  191.         ((eq *value-to-go* 'trash)
  192.          (cond ((and (consp loc)
  193.                      (member (car loc)
  194.                              '(INLINE INLINE-COND INLINE-FIXNUM inline-integer
  195.                                INLINE-CHARACTER INLINE-LONG-FLOAT
  196.                                INLINE-SHORT-FLOAT))
  197.                      (cadr loc))
  198.                 (wt-nl "(void)(") (wt-inline t (caddr loc) (cadddr loc))
  199.                 (wt ");"))
  200.                ((and (consp loc) (eq (car loc) 'SIMPLE-CALL))
  201.                 (wt-nl "(void)" loc ";"))))
  202.         ((eq *value-to-go* 'top)
  203.          (unless (eq loc 'fun-val) (set-top loc)))
  204.         ((eq *value-to-go* 'return-fixnum) (set-return-fixnum loc))
  205.         ((eq *value-to-go* 'return-character) (set-return-character loc))
  206.         ((eq *value-to-go* 'return-long-float) (set-return-long-float loc))
  207.         ((eq *value-to-go* 'return-short-float) (set-return-short-float loc))
  208.         ((or (not (consp *value-to-go*))
  209.              (not (symbolp (car *value-to-go*))))
  210.          (baboon))
  211.         ((setq fd (get (car *value-to-go*) 'set-loc))
  212.          (apply fd loc (cdr *value-to-go*)))
  213.         ((setq fd (get (car *value-to-go*) 'wt-loc))
  214.          (wt-nl) (apply fd (cdr *value-to-go*)) (wt "= " loc ";"))
  215.         (t (baboon)))
  216.   )
  217.  
  218. )
  219.